Shareware Grab Bag/Shareware Grab Bag.iso/090/bytjl86b.arc/ANAGRAM.PAS

Pascal/Delphi Source File | 1985-07-12 | 7KB | 271 lines

program Anagram;

{Copyright 1985 by Bob Keefer}

{Anagram.Pas takes a word of up to 10 letters from
the keyboard and rearranges the letters into every
possible permutation, or anagram, of the word.}

{It then evaluates the likelihood that each anagram
is an English word by looking up every trigram in
the word in a probability table, which is stored in
a separate file PROB.DAT and is read into the array
Probability[X,Y,Z]. Finally, it records the top
scoring anagrams in Scoreboard and prints them to
the screen.}

{The program must be compiled with the Turbo
 "c" compiler option to a *.COM file.}


{$A-} {compiler directive for recursion}
{$C-} {.... ignore ^C and ^S breaks}
{$I-} {.... no i/o checking}
{$V-} {.... no string checking}



const
     MaxLength = 13;   {biggest word + 3}
     MaxScores = 15 ;  {how many winners to store}

type
    ScoreLine = record {One line of the Scoreboard}
              Winner : string[MaxLength] ;
              Points : integer ;
              end;

var
   Word : array [1..Maxlength] of char;  {Word to permute}
   Wordlength : integer; {Length of Word}
   Probability : array [0..26,0..26,0..26] of integer;
   ScoreBoard : array [1..MaxScores] of ScoreLine;
   WordToScore : string[Maxlength]; {anagram}
   DataFile : file of integer; {probability table}
   TheWord : String[Maxlength]; {Word as string}
   I : integer; {counter}



procedure Score;

var
   X,Y,Z,I,J : integer ;
   Total : integer ;
   Unlikelihood : integer;


   procedure KeepScore;

    var
       N : integer;

       procedure ChalkItUp;
           var
                TempScore, I : integer;
                TempName : String[MaxLength];

       begin  {ChalkItUp}
           for I := N to MaxScores do
           begin
                with ScoreBoard[I] do   {If an anagram}
                if Total>Points then    {scores better,}
                begin                   {then record it...}
                     begin
                          TempScore := Points;
                          TempName := Winner;
                          Points := Total;
                          Winner := WordToScore
                     end;
                     if I<>MaxScores then

                     begin {..bump the rest down}
                          with ScoreBoard[I+1] do
                          begin
                               WordToScore := TempName;
                               Total := TempScore;
                          end;
                     end;
                end;
           end;
       end;   {ChalkItUp}


begin {KeepScore}
      for N := 1 to MaxScores do
      begin
           if WordToScore = ScoreBoard[N].Winner
              then Total := 0; {eliminate duplicates}
           if (Total > ScoreBoard[N].Points)
               then ChalkItUp;
           {record good-scoring words}
      end;
end;  {KeepScore}


begin {procedure Score}
     WordToScore := ' ' + WordToScore + ' ';
     Total := 0;
     Unlikelihood := 0;
     for I := 1 to length(WordToScore) -2 do
     begin
          X := ord(copy(WordToScore,I,1))-64;
          Y := ord(copy(WordToScore,I+1,1))-64;
          Z := ord(copy(WordToScore,I+2,1))-64;
          if X<0 then X:=0;
          if Y<0 then Y:=0;
          if Z<0 then Z:=0;

          Total := Total + Probability[X,Y,Z];
          if Probability[X,Y,Z]=0 then Unlikelihood := succ(Unlikelihood);
     end;
     for J := 1 to Unlikelihood do Total := Total div 2;
     KeepScore;
end;  {procedure Score}



procedure Permute (CurrentLength : integer);

var
   I : integer;

   procedure Switch;
   var
      Temp : char;
   begin
        Temp := Word[CurrentLength];
        Word[CurrentLength] := Word[I];
        Word[I] := Temp;
   end; {Switch}


   procedure Outword;

      begin
         WordToScore:='';
         for I := 1 to Wordlength do
         WordToScore := WordToScore + Word[I];
      end; {Outword}

begin {Permute body}
      if CurrentLength = 1
      then begin
                Outword;
                Score;
           end
      else for I := 1 to CurrentLength do
          begin
               Switch;
               Permute(CurrentLength - 1);
               Switch;
          end;
end; {Permute}


procedure GetInput;

var
  I : integer;

begin
     write('Enter word: ');
     readln(TheWord);
     WordLength := length(TheWord);
     for I := 1 to WordLength do
     begin
          Word[I] := upcase(copy(TheWord,I,1));
     end;
     TheWord := '';
     for I := 1 to WordLength do
         TheWord := TheWord + Word[I];

end; {procedure GetInput}

procedure ZeroScore;
var I : integer;

begin
     for I:= 1 to MaxScores do
     begin
          with ScoreBoard[I] do
          begin
               Points := 0;
               Winner := '';
          end;
     end; {with}
end; {ZeroScore}


procedure PostScore;

var
   I : integer;
   GotIt : boolean;

begin
     GotIt:=false;
     for I := 1 to MaxScores do
     begin
          with ScoreBoard[I] do
          begin
               if Points>0 then
               writeln(I:2, ' ',Winner, '  ', Points);
          end; {with}
     end; {for loop}
end; {procedure PostScore}

procedure ReadProb;

var X,Y,Z : integer;

begin
     assign(Datafile,'PROB.DAT');
     reset(DataFile);
     for X := 0 to 26 do begin
         write('*');
         for Y := 0 to 26 do begin
             for Z := 0 to 26 do begin
                  read(Datafile,Probability[X,Y,Z]);
             end;
         end;
     end;
     close(Datafile);
     writeln;
end;  {procedure ReadProb}


procedure SignOn;
begin
     clrscr;
     writeln('Anagram.Pas');
     writeln('By Bob Keefer');
     writeln('Copyright 1985');
     writeln;
     writeln;
     writeln('To halt program, enter "*"');
     writeln;
     writeln;
     writeln;
     writeln('Reading Probability Table...');
end; {procedure Signon}


begin {Anagram program}
      SignOn;      {Display signon message}
      ReadProb;    {Read probability table}
      clrscr;
      repeat
            GetInput;               {Get word}
            ZeroScore;              {clear Scoreboard}
            Permute (Wordlength);   {Evaluate words}
            writeln;
            PostScore;              {Print results}
            writeln;
            writeln;
      until Word[1]='*';
end.
;
      until Word[1]='*';
end.